home *** CD-ROM | disk | FTP | other *** search
/ Shareware Games Galore! / Shareware Games Galore!.iso / arcade / advsrc / db.for < prev    next >
Encoding:
Text File  |  1993-03-27  |  26.6 KB  |  894 lines
  1. C  Adventure Binary Data Base Generator From ASCII File--storage 2
  2. c   Written for MS DOS PDS FORTRAN v5.10 
  3. c    by Paul Muñoz-Colman, FunStuff Software
  4. c   27 Mar 1993  
  5. c   12 August 1985
  6. C
  7. $NODEBUG
  8. $notstrict
  9. $storage: 2
  10.       IMPLICIT INTEGER*2 (A-Z)
  11.       COMMON /TXTCOM/ RTEXT
  12.       COMMON /BLKCOM/ BLKLIN
  13.       COMMON /VOCCOM/ KTAB,ATAB,TABSIZ
  14.       COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
  15.       COMMON /MTXCOM/ MTEXT
  16.       COMMON /PTXCOM/ PTEXT
  17.       COMMON /ABBCOM/ ABB
  18.       COMMON /concom/ COND
  19.       COMMON /LOCCOM/ LOC
  20.       COMMON /PROCOM/ prop, lamp
  21.       COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
  22.      1          SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
  23.  
  24.       COMMON /lincom/ LINES
  25.       CHARACTER*2 LINES (21150),CLINES
  26.       CHARACTER*4 WD1,WD2,IZ,BL,ATAB(295),TK(20)
  27.       CHARACTER*12 FNAME
  28.       INTEGER*4 TRAVEL(745),ITK(20),IZZ,IBL,ILINES,newloc,klong,llong
  29.       integer*4 kklong,linuse,kk,linsiz,ran
  30.       DIMENSION KTAB(295),RTEXT(205)
  31.       DIMENSION LTEXT(150),STEXT(150),KEY(150),COND(150),ABB(150),
  32.      1          ATLOC(150)
  33.       DIMENSION PLAC(100),PLACE(100),FIXD(100),FIXED(100),LINK(200),
  34.      1          PTEXT(100),PROP(100)
  35.       DIMENSION ACTSPK(35)
  36.       DIMENSION CTEXT(12),CVAL(12)
  37.       DIMENSION HINTLC(20),HINTED(20),HINTS(20,4)
  38.       DIMENSION MTEXT(35)
  39.       DIMENSION DSEEN(6),DLOC(6),ODLOC(6),HNAME(4)
  40.       INTEGER*2 IDONDX
  41. C
  42.       EQUIVALENCE(IZ,IZZ),(BL,IBL),(TK,ITK),(CLINES,ILINES)
  43.       DATA LINSIZ/21150/,TRVSIZ/745/,LOCSIZ/150/,
  44.      1        VRBSIZ/35/,RTXSIZ/205/,CLSMAX/12/,HNTSIZ/20/,MAGSIZ/35/
  45.       DATA BL/'    '/,IZZ/0/
  46. C
  47.       bitset(l,n)=mod(shift(cond(l),-n),2)
  48.       liq2(pbotl)=(1-pbotl)*water+(pbotl/2)*(water+oil)
  49.       liqloc(loc)=liq2((mod(cond(loc)/2*2,8)-5)*mod(cond(loc)/4,2)+1)
  50.       liq(dummy)=liq2(max0(prop(bottle),-1-prop(bottle)))
  51. c
  52.       SETUP = 0
  53.       TABSIZ=295
  54.       BLKLIN = 1
  55.  
  56.       IF(SETUP.NE.0)GOTO 1100
  57.       WRITE (*,1000)
  58.  1000 FORMAT(//' IBM PC Adventure Binary Data Base Writer!',//,
  59.      .  ' Initializing..Please Wait..',//)
  60.  
  61.       DO 1001 I=1,300
  62.       IF(I.LE.100)PTEXT(I)=0
  63.       IF(I.LE.RTXSIZ)RTEXT(I)=0
  64.       IF(I.LE.CLSMAX)CTEXT(I)=0
  65.       IF(I.LE.MAGSIZ)MTEXT(I)=0
  66.       IF(I.GT.LOCSIZ)GOTO 1001
  67.       STEXT(I)=0
  68.       LTEXT(I)=0
  69.       COND(I)=0
  70.  1001 CONTINUE
  71.       FNAME='ADVEDAT.ASC'
  72.       OPEN (1, FILE=FNAME)
  73.       REWIND 1
  74.       SETUP=1
  75.       LINUSE=1
  76.       TRVS=1
  77.       CLSSES=1
  78. c  start new data section.  sect is the section number.
  79.  1002 read(1,1003)sect
  80.  1003 format(i4)
  81.       oldloc=-1
  82.       if(sect.gt.11) call bug(9)
  83. c
  84.       if (sect .ne. 0) write (*,10031) sect
  85. 10031 format (1h ,i2/)
  86.       goto(1100,1004,1004,1030,1040,1004,1004,1050,1060,1070,1004,
  87.      1    1080),(sect+1)
  88. c           (0)  (1)  (2)  (3)  (4)  (5)  (6)  (7)  (8)  (9)  (10)
  89. c          (11)
  90. c  sections 1, 2, 5, 6, 10.  read messages and set up pointers.
  91.  1004 read(1,1005)loc,(lines(linuse+j),j=1,36)
  92.  1005 format(i4,36a2)
  93. c
  94.       if(loc.eq.-1)goto 1002
  95.       do 1006 k=1,36
  96.       kk=linuse+37-k
  97.       if(lines(kk).ne.'  ')go to 1007
  98.  1006 continue
  99.       call bug(1)
  100.  1007 ilines=kk+1
  101.       lines(linuse)=clines
  102.       if(loc.eq.oldloc)goto 1020
  103.       ilines=-ilines
  104.       lines(linuse)=clines
  105.       if(sect.eq.10)goto 1012
  106.       if(sect.eq.6)goto 1011
  107.       if(sect.eq.5)goto 1010
  108.       if(sect.eq.1)goto 1008
  109.       stext(loc)=linuse
  110.       goto 1020
  111.  
  112.  1008 ltext(loc)=linuse
  113.       goto 1020
  114.  
  115.  1010 if(loc.gt.0.and.loc.le.100)ptext(loc)=linuse
  116.       goto 1020
  117.  
  118.  1011 if(loc.gt.rtxsiz)call bug(6)
  119.       rtext(loc)=linuse
  120.       goto 1020
  121.  
  122.  1012 ctext(clsses)=linuse
  123.       cval(clsses)=loc
  124.       clsses=clsses+1
  125.       goto 1020
  126.  
  127.  1020 linuse=kk+1
  128.       ilines=-1
  129.       lines(linuse)=clines
  130.       oldloc=loc
  131.       if(linuse+36.gt.linsiz)call bug(2)
  132.       goto 1004
  133.  
  134. c  the stuff for section 3 is encoded here.  each "from-location" gets a
  135. c  contiguous section of the "travel" array.  each entry in travel is
  136. c  newloc*1000 + keyword (from section 4, motion verbs), and is negated if
  137. c  this is the last entry for this location.  key(n) is the index in travel
  138. c  of the first option at location n.
  139.  
  140.  1030 read(1,1031)loc,newloc,(itk(l),l=1,9)
  141.  1031 format(i4,10i7)
  142.       if(loc.eq.-1)goto 1002
  143.       if(key(loc).ne.0)goto 1033
  144.       key(loc)=trvs
  145.       goto 1035
  146.  1033 travel(trvs-1)=-travel(trvs-1)
  147.  1035 do 1037 l=1,9
  148.       if(itk(l).eq.0)goto 1039
  149.       travel(trvs)=newloc*1000+itk(l)
  150.       trvs=trvs+1
  151.       if(trvs.eq.trvsiz)call bug(3)
  152.  1037 continue
  153.  1039 travel(trvs-1)=-travel(trvs-1)
  154.       goto 1030
  155.  
  156. c  here we read in the vocabulary.  ktab(n) is the word number, atab(n) is
  157. c  the corresponding word.  the -1 at the end of section 4 is left in ktab
  158. c  as an end-marker.
  159. c
  160. c
  161.  
  162.  1040 do 1042 tabndx=1,tabsiz
  163.  1043 read(1,1041)ktab(tabndx),atab(tabndx)
  164.  1041 format(i4,a4)
  165.       if(ktab(tabndx).eq.-1)goto 1002
  166.  1042 continue
  167.       call bug(4)
  168.  
  169. c  read in the initial locations for each object.  also the immovability info.
  170. c  plac contains initial locations of objects.  fixd is -1 for immovable
  171. c  objects (including the snake), or = second loc for two-placed objects.
  172.  
  173.  1050 read(1,1031)obj,j,k
  174.       if(obj.eq.-1)goto 1002
  175.       plac(obj)=j
  176.       fixd(obj)=k
  177.       goto 1050
  178.  
  179. c  read default message numbers for action verbs, store in actspk.
  180.  
  181.  1060 read(1,1031)verb,j
  182.       if(verb.eq.-1)goto 1002
  183.       actspk(verb)=j
  184.       goto 1060
  185.  
  186. c  read info about available liquids and other conditions, store in cond.
  187.  
  188.  1070 read(1,1031)k,(itk(i),i=1,10)
  189.       if(k.eq.-1)goto 1002
  190.       do 1071 i=1,10
  191.       loc=itk(i)
  192.       if(loc.eq.0)goto 1070
  193.       if(bitset(loc,k).eq.1)call bug(8)
  194.  1071 cond(loc)=cond(loc)+shift(1,k)
  195.       goto 1070
  196.  
  197. c  read data for hints.
  198.  
  199.  1080 hntmax=0
  200.  1081 read(1,1031)k,(itk(i),i=1,4)
  201.       if(k.eq.-1)goto 1002
  202.       if(k.lt.0.or.k.gt.hntsiz)call bug(7)
  203.       do 1083 i=1,4
  204.  1083 hints(k,i)=itk(i)
  205.       hntmax=max0(hntmax,k)
  206.       goto 1081
  207. c  finish constructing internal data format
  208.  
  209. 1100  CLOSE (1)
  210. C  HAVING READ IN THE DATABASE, CERTAIN THINGS ARE NOW CONSTRUCTED.  PROPS ARE
  211. C  SET TO ZERO.  WE FINISH SETTING UP COND BY CHECKING FOR FORCED-MOTION TRAVEL
  212. C  ENTRIES.  THE PLAC AND FIXD ARRAYS ARE USED TO SET UP ATLOC(N) AS THE FIRST
  213. C  OBJECT AT LOCATION N, AND LINK(OBJ) AS THE NEXT OBJECT AT THE SAME LOCATION
  214. C  AS OBJ.  (OBJ>100 INDICATES THAT FIXED(OBJ-100)=LOC; LINK(OBJ) IS STILL THE
  215. C  CORRECT LINK TO USE.)  ABB IS ZEROED; IT CONTROLS WHETHER THE ABBREVIATED
  216. C  DESCRIPTION IS PRINTED.  COUNTS MOD 5 UNLESS "LOOK" IS USED.
  217.  
  218.       DO 1101 I=1,100
  219.       PLACE(I)=0
  220.       PROP(I)=0
  221.       LINK(I)=0
  222.  1101 LINK(I+100 )=0
  223.  
  224.       DO 1102 I=1,LOCSIZ
  225.       ABB(I)=0
  226.       IF(LTEXT(I).EQ.0.OR.KEY(I).EQ.0)GOTO 1102
  227.       K=KEY(I)
  228.       IF(MOD(IABS(TRAVEL(K)),1000).EQ.1)COND(I)=2
  229.  1102 ATLOC(I)=0
  230.  
  231. C  SET UP THE ATLOC AND LINK ARRAYS AS DESCRIBED ABOVE.  WE'LL USE THE DROP
  232. C  SUBOUTINE, WHICH PREFACES NEW OBJECTS ON THE LISTS.  SINCE WE WANT THINGS
  233. C  IN THE OTHER ORDER, WE'LL RUN THE LOOP BACKWARDS.  IF THE OBJECT IS IN TWO
  234. C  LOCS, WE DROP IT TWICE.  THIS ALSO SETS UP "PLACE" AND "FIXED" AS COPIES OF
  235. C  "PLAC" AND "FIXD".  ALSO, SINCE TWO-PLACED OBJECTS ARE TYPICALLY BEST
  236. C  DESCRIBED LAST, WE'LL DROP THEM FIRST.
  237.  
  238.       DO 1106 I=1,100
  239.       K=101-I
  240.       IF(FIXD(K).LE.0)GOTO 1106
  241.       CALL DROP(K+100,FIXD(K))
  242.       CALL DROP(K,PLAC(K))
  243.  1106 CONTINUE
  244.  
  245.       DO 1107 I=1,100
  246.       K=101-I
  247.       FIXED(K)=FIXD(K)
  248.  1107 IF(PLAC(K).NE.0.AND.FIXD(K).LE.0)CALL DROP(K,PLAC(K))
  249.  
  250. C  TREASURES, AS NOTED EARLIER, ARE OBJECTS 50 THROUGH MAXTRS (CURRENTLY 79).
  251. C  THEIR PROPS ARE INITIALLY -1, AND ARE SET TO 0 THE FIRST TIME THEY ARE
  252. C  DESCRIBED.  TALLY KEEPS TRACK OF HOW MANY ARE NOT YET FOUND, SO WE KNOW
  253. C  WHEN TO CLOSE THE CAVE.  TALLY2 COUNTS HOW MANY CAN NEVER BE FOUND (E.G. IF
  254. C  LOST BIRD OR BRIDGE).
  255.  
  256.       MAXTRS=79
  257.       TALLY=0
  258.       TALLY2=0
  259.       DO 1200 I=50,MAXTRS
  260.       IF(PTEXT(I).NE.0)PROP(I)=-1
  261.  1200 TALLY=TALLY-PROP(I)
  262.  
  263. C  CLEAR THE HINT STUFF.  HINTLC(I) IS HOW LONG HE'S BEEN AT LOC WITH COND BIT
  264. C  I.  HINTED(I) IS TRUE IFF HINT I HAS BEEN USED.
  265.  
  266.       DO 1300 I=1,HNTMAX
  267.       HINTED(I)=0
  268.  1300 HINTLC(I)=0
  269.  
  270. c  define some handy mnemonics.  these correspond to object numbers.
  271.  
  272.       keys=vocab('keys',1)
  273.       lamp=vocab('lamp',1)
  274.       grate=vocab('grat',1)
  275.       cage=vocab('cage',1)
  276.       rod=vocab('rod ',1)
  277.       rod2=rod+1
  278.       steps=vocab('step',1)
  279.       bird=vocab('bird',1)
  280.       door=vocab('door',1)
  281.       pillow=vocab('pill',1)
  282.       snake=vocab('snak',1)
  283.       fissur=vocab('fiss',1)
  284.       tablet=vocab('tabl',1)
  285.       clam=vocab('clam',1)
  286.       oyster=vocab('oyst',1)
  287.       magzin=vocab('maga',1)
  288.       dwarf=vocab('dwar',1)
  289.       knife=vocab('knife',1)
  290.       food=vocab('food',1)
  291.       bottle=vocab('bott',1)
  292.       water=vocab('wate',1)
  293.       oil=vocab('oil ',1)
  294.       plant=vocab('plan',1)
  295.       plant2=plant+1
  296.       axe=vocab('axe ',1)
  297.       mirror=vocab('mirr',1)
  298.       dragon=vocab('drag',1)
  299.       chasm=vocab('chas',1)
  300.       troll=vocab('trol',1)
  301.       troll2=troll+1
  302.       bear=vocab('bear',1)
  303.       messag=vocab('mess',1)
  304.       vend=vocab('vend',1)
  305.       batter=vocab('batt',1)
  306.  
  307. c  objects from 50 through whatever are treasures.  here are a few.
  308.  
  309.       nugget=vocab('gold',1)
  310.       coins=vocab('coins',1)
  311.       chest=vocab('chest',1)
  312.       eggs=vocab('eggs',1)
  313.       tridnt=vocab('trid',1)
  314.       vase=vocab('vase',1)
  315.       emrald=vocab('emer',1)
  316.       pyram=vocab('pyra',1)
  317.       pearl=vocab('pear',1)
  318.       rug=vocab('rug ',1)
  319.       chain=vocab('chai',1)
  320.       spices=vocab('spic',1)
  321.  
  322. c  these are motion-verb numbers.
  323.  
  324.       back=vocab('back',0)
  325.       look=vocab('look',0)
  326.       cave=vocab('cave',0)
  327.       null=vocab('null',0)
  328.       entrnc=vocab('entr',0)
  329.       dprssn=vocab('depr',0)
  330.  
  331. c  and some action verbs.
  332.  
  333.       say=vocab('say ',2)
  334.       lock=vocab('lock',2)
  335.       throw=vocab('thro',2)
  336.       find=vocab('find',2)
  337.       invent=vocab('inve',2)
  338.  
  339.       CHLOC=114
  340.       CHLOC2=140
  341.       DO 1700 I=1,6
  342. 1700    DSEEN(I)=0
  343.       DFLAG=0
  344.       DLOC(1)=19
  345.       DLOC(2)=27
  346.       DLOC(3)=33
  347.       DLOC(4)=44
  348.       DLOC(5)=64
  349.       DLOC(6)=CHLOC
  350.       DALTLC=18
  351.  
  352.       TURNS=0
  353.       LMWARN=0
  354.       IWEST=0
  355.       KNFLOC=0
  356.       DETAIL=0
  357.       ABBNUM=5
  358.       DO 1800 I=1,5
  359.  1800 IF(RTEXT(2*I+79).NE.0)MAXDIE=I
  360.       NUMDIE=0
  361.       HOLDNG=0
  362.       DKILL=0
  363.       FOOBAR=0
  364.       BONUS=0
  365.       CLOCK1=30
  366.       CLOCK2=50
  367.       SAVED=0
  368.       CLOSNG=0
  369.       PANIC=0
  370.       CLOSED=0
  371.       GAVEUP=0
  372.       SCORNG=0
  373.  
  374.       DO 1998 K=1,LOCSIZ
  375.       KK=LOCSIZ+1-K
  376.       IF(LTEXT(KK).NE.0)GOTO 1997
  377.  1998 CONTINUE
  378.  
  379.       OBJ=0
  380.  1997 DO 1996 K=1,100
  381.  1996 IF(PTEXT(K).NE.0)OBJ=OBJ+1
  382.  
  383.       DO 1995 K=1,TABNDX
  384.  1995 IF(KTAB(K)/1000.EQ.2)VERB=KTAB(K)-2000
  385.  
  386.       DO 1994 K=1,RTXSIZ
  387.       J=RTXSIZ+1-K
  388.       IF(RTEXT(J).NE.0)GOTO 1993
  389.  1994 CONTINUE
  390.  
  391.  1993 DO 1992 K=1,MAGSIZ
  392.       I=MAGSIZ+1-K
  393.       IF(MTEXT(I).NE.0)GOTO 1991
  394.  1992 CONTINUE
  395.  
  396.  1991 K=100
  397.       WRITE (*,1999) LINUSE,LINSIZ,TRVS,TRVSIZ,TABNDX,TABSIZ
  398.       WRITE (*,19992)KK,LOCSIZ,OBJ,K,VERB,VRBSIZ,J,RTXSIZ,CLSSES,CLSMAX
  399.       WRITE (*,19993) HNTMAX,HNTSIZ,I,MAGSIZ
  400.  1999 FORMAT (' TABLE SPACE USED:'/
  401.      1 ' ',I6,' OF ',I6,' WORDS OF MESSAGES'/
  402.      2 ' ',I6,' OF ',I6,' TRAVEL OPTIONS'/
  403.      3 ' ',I6,' OF ',I6,' VOCABULARY WORDS'/)
  404. 19992 FORMAT ( ' ',I6,' OF ',I6,' LOCATIONS'/
  405.      5 ' ',I6,' OF ',I6,' OBJECTS'/
  406.      6 ' ',I6,' OF ',I6,' ACTION VERBS'/
  407.      7 ' ',I6,' OF ',I6,' RTEXT MESSAGES'/
  408.      8 ' ',I6,' OF ',I6,' CLASS MESSAGES'/)
  409. 19993 FORMAT ( ' ',I6,' OF ',I6,' HINTS'/
  410.      9 ' ',I6,' OF ',I6,' MAGIC MESSAGES'/)
  411. c
  412. c  save the data base in array format
  413. c
  414.       open (2,file='ad.dat',status='unknown',form='unformatted')
  415. c
  416.       write (2) abbnum,axe,back,batter,bear,bird,bonus,bottle,
  417.      .  cage,cave,chain,chasm,chest,chloc,chloc2,clam,
  418.      .  clock1,clock2,closed,closng,coins,daltlc,detail,dflag,
  419.      .  dkill,dloc,door,dprssn,dragon,dseen,dwarf,eggs,
  420.      .  emrald,entrnc,find,fissur,foobar,food,gaveup,grate
  421. c
  422.       write (2) invent,iwest,keys,knfloc,knife,lamp,lmwarn,
  423.      .  lock,look,magzin,maxdie,maxtrs,messag,mirror,nugget,
  424.      .  null,numdie,oil,oyster,panic,pearl,pillow,plant,
  425.      .  plant2,pyram,rod,rod2,rug,saved,say,scorng,
  426.      .  snake,spices,steps,tablet,tally,tally2,throw,tridnt,
  427.      .  troll,troll2,turns,vase,vend,water,tabsiz,blklin,oldloc,fixed
  428. c
  429.       write (2) linuse,trvs,tabndx,obj,verb,clsses,hntmax,loc,newloc,
  430.      .  k,j,stext,ltext,ptext,rtext,ctext,cval,key,
  431.      .  travel,ktab,plac,fixd,actspk,cond,hints,place,prop,link,
  432.      .  abb,atloc,holdng,hinted,hintlc,kk,i,itk,atab,lines
  433. c
  434.       endfile 2
  435.       close (2)
  436.  
  437.  1    CONTINUE
  438. C1    DEMO=START(0)
  439. C     CALL MOTD(0)
  440.       write (*,*) 'Finished'
  441.  
  442.       END
  443. c  subroutines and functions
  444.       subroutine speak(n)
  445. c  print the message which starts at lines(n).  precede it with a blank line
  446. c  unless blklin is false.
  447.       implicit integer*2 (a-z)
  448.       common /lincom/ lines
  449.       common /txtcom/ rtext
  450.       common /blkcom/ blklin
  451.       dimension rtext (205)
  452.       character*2 lines (21150)
  453.       character*2 np,clines
  454.       equivalence (clines,ilines)
  455.       data np/'>$'/
  456.       if(n.eq.0)return
  457.       if(lines(n+1).eq.np)return
  458.       if(blklin.eq.1) write (*,2)
  459.       k=n
  460.  1    clines=lines(k)
  461.       l=iabs(ilines)-1
  462.       k=k+1
  463.       write (*, 2) (lines(i),i=k,l)
  464.  2    format(' ',36a2)
  465.       k=l+1
  466.       clines=lines(k)
  467.       if(ilines.ge.0) go to 1
  468.       return
  469.       end
  470.  
  471.       subroutine pspeak(msg,skip)
  472. c  find the skip+1st message from msg and print it.  msg should be the index of
  473. c  the inventory message for object.  (inven+n+1 message is prop=n message).
  474.       implicit integer*2 (a-z)
  475.       common /lincom/ lines
  476.       common /txtcom/ rtext
  477.       common /ptxcom/ ptext
  478.       character*2 lines (21150),clines
  479.       dimension rtext(205),ptext(100)
  480.       equivalence (clines,ilines)
  481.       m=ptext(msg)
  482.       if(skip.lt.0)goto 9
  483.       do 3 i=1,skip+1
  484.  1    clines=lines(m)
  485.       m=iabs(ilines)
  486.       clines=lines(m)
  487.       if(ilines.ge.0) go to 1
  488.  3    continue
  489.  9    call speak(m)
  490.       return
  491.       end
  492.  
  493.       subroutine rspeak(i)
  494. c  print the i-th "random" message (section 6 of database).
  495.       implicit integer*2 (a-z)
  496.       common /txtcom/ rtext
  497.       dimension rtext(205)
  498.       if(i.ne.0)call speak(rtext(i))
  499.       return
  500.       end
  501.  
  502.       integer*2 function yes(x,y,z)
  503. c  call yesx (below) with messages from section 6.
  504.       implicit integer*2 (a-z)
  505.       yes=yesx(x,y,z)
  506.       return
  507.       end
  508.  
  509.       integer*2 function yesx(x,y,z)
  510. c  print message x, wait for yes/no answer.  if yes, print y and leave yea
  511. c  true; if no, print z and leave yea false.
  512.       implicit integer*2 (a-z)
  513.       character*4 reply,junk1,junk2,junk3
  514.  1    if(x.ne.0) call rspeak (x)
  515.       call getin(reply,junk1,junk2,junk3)
  516.       if(reply.eq.'yes '.or.reply.eq.'y   ')goto 10
  517.       if(reply.eq.'no  '.or.reply.eq.'n   ')goto 20
  518.       write (*,9)
  519.  9    format(/' Please answer the question "yes" or "no".')
  520.       goto 1
  521.  10   yesx=1
  522.       if(y.ne.0) call rspeak (y)
  523.       return
  524.  20   yesx=0
  525.       if(z.ne.0) call rspeak (z)
  526.       return
  527.       end
  528.  
  529.       subroutine a5toa1 (a, b, c, d, chars, leng)
  530. c   a & b contain a 1 to 8-character word in a4 format.  c & d contain
  531. c  another word and/or punctuation. they are unpacked to one character
  532. c  per word in the array "chars", with exactly one blank between b & c
  533. c  (or none, if c is zero).  the index of the last non-blank character
  534. c  in chars is returned in leng.
  535.       implicit integer*2 (a-z)
  536.       integer*4 ic
  537.       character *20 aaa
  538.       character *4 a,b,c,d,aa(5),cc
  539.       character *1 chars(20),raw(20)
  540.       equivalence (aaa,aa),(cc,ic)
  541. c  do first word until a blank
  542.       aa(1) = a
  543.       aa(2) = b
  544.       call unpack (aaa, raw)
  545. c  clear output array and move, counting to first blank
  546.       leng=0
  547.       do 2 i=1,20
  548. 2     chars(i)=' '
  549.       do 1 i=1,8
  550.       if (raw(i).eq.' ') go to 3
  551.       chars(i)=raw(i)
  552. 1     leng=i
  553. c  leng doesn't include trailing blank
  554. 3     cc=c
  555.       if(ic.eq.0) go to 99
  556. c  second word--ignore leading blanks, stop at trailing one
  557.       chars(leng+1)=' '
  558.       leng=leng+1
  559.       ll=leng
  560.       aa(1)=c
  561.       aa(2)=d
  562.       call unpack (aaa,raw)
  563. c  skip leading blank if any
  564.       do 4 j=1,8
  565. 4     if (raw(j).ne.' ') go to 5
  566. c  second word was all blank--fooey
  567.       go to 99
  568. c  do non-blanks
  569. 5     do 6 k=j,8
  570.       if (raw(k).eq.' ') go to 99
  571.       chars (k-j+1+ll) = raw(k)
  572. 6     leng=leng+1
  573. 99    return
  574.       end
  575. c
  576.       integer*2 function vocab(id,init)
  577. c  look up id in the vocabulary (atab) and return its "definition" (ktab), or
  578. c  -1 if not found.  if init is positive, this is an initialization call setting
  579. c  up a keyword variable, and not finding it constitutes a bug.  it also means
  580. c  that only ktab values which taken over 1000 equal init may be considered.
  581. c  (thus "steps", which is a motion verb as well as an object, may be located
  582. c  as an object.)  and it also means the ktab value is taken mod 1000.
  583.       implicit integer*2 (a-z)
  584.       common /voccom/ ktab,atab,tabsiz
  585.       character*4 atab(295),id
  586.       dimension ktab(295)
  587.       do 1 i=1,tabsiz
  588.       if(ktab(i).eq.-1)goto 2
  589.       if(init.ge.0.and.ktab(i)/1000.ne.init)goto 1
  590.       if(atab(i).eq.id)goto 3
  591.  1    continue
  592.  10   format(1x,i4,2x,a4)
  593.       call bug(21)
  594.  2    vocab=-1
  595.       if(init.lt.0)return
  596.       write (*,10) init, id
  597.       call bug(5)
  598.  3    vocab=ktab(i)
  599.       if(init.ge.0)vocab=mod(vocab,1000)
  600.       return
  601.       end
  602.  
  603.       subroutine dstroy(object)
  604. c  permanently eliminate "object" by moving to a non-existent location.
  605.       implicit integer*2 (a-z)
  606.       call move(object,0)
  607.       return
  608.       end
  609.  
  610.       subroutine juggle(object)
  611. c  juggle an object by picking it up and putting it down again, the purpose
  612. c  being to get the object to the front of the chain of things at its loc.
  613.       implicit integer*2 (a-z)
  614.       common /placom/ atloc,link,place,fixed,holdng
  615.       dimension atloc(150),link(200),place( 100),fixed(100)
  616.       i=place(object)
  617.       call move(object,i)
  618.       call move(object+100,j)
  619.       return
  620.       end
  621.  
  622.       subroutine move(object,where)
  623.  
  624. c  place any object anywhere by picking it up and dropping it.  may already be
  625. c  toting, in which case the carry is a no-op.  mustn't pick up objects which
  626. c  are not at any loc, since carry wants to remove objects from atloc chains.
  627.       implicit integer*2 (a-z)
  628.       common /placom/ atloc,link,place,fixed,holdng
  629.       dimension atloc(150),link(200),place( 100),fixed(100)
  630.       if(object.gt.100)goto 1
  631.       from=place(object)
  632.       goto 2
  633.  1    from=fixed(object-100)
  634.  2    if(from.gt.0.and.from.le.300)call carry(object,from)
  635.       call drop(object,where)
  636.       return
  637.       end
  638.  
  639.       integer*2 function put(object,where,pval)
  640.  
  641. c  put is the same as move, except it returns a value used to set up the
  642. c  negated prop values for the repository objects.
  643.       implicit integer*2 (a-z)
  644.       call move(object,where)
  645.       put=(-1)-pval
  646.       return
  647.       end
  648.  
  649.       subroutine carry(object,where)
  650. c  start toting an object, removing it from the list of things at its former
  651. c  location.  incr holdng unless it was already being toted.  if object>100
  652. c  (moving "fixed" second loc), don't change place or holdng.
  653.       implicit integer*2 (a-z)
  654.       common /placom/ atloc,link,place,fixed,holdng
  655.       dimension atloc(150),link(200),place( 100),fixed(100)
  656.       if(object.gt.100)goto 5
  657.       if(place(object).eq.-1)return
  658.       place(object)=-1
  659.       holdng=holdng+1
  660.  5    if(atloc(where).ne.object)goto 6
  661.       atloc(where)=link(object)
  662.       return
  663.  6    temp=atloc(where)
  664.  7    if(link(temp).eq.object)goto 8
  665.       temp=link(temp)
  666.       goto 7
  667.  8    link(temp)=link(object)
  668.       return
  669.       end
  670.  
  671.       subroutine drop(object,where)
  672. c  place an object at a given loc, prefixing it onto the atloc list.  decr
  673. c  holdng if the object was being toted.
  674.       implicit integer*2 (a-z)
  675.       common /placom/ atloc,link,place,fixed,holdng
  676.       dimension atloc(150),link(200),place( 100),fixed(100)
  677.       if(object.gt.100)goto 1
  678.       if(place(object).eq.-1)holdng=holdng-1
  679.       place(object)=where
  680.       goto 2
  681.  1    fixed(object-100)=where
  682.  2    if(where.le.0)return
  683.       link(object)=atloc(where)
  684.       atloc(where)=object
  685.       return
  686.       end
  687.  
  688. c  utility routines (shift, bug)
  689.       integer*2 function shift (val, dist)
  690. c return val shifted (left if dist>0, else right) dist bits
  691.       implicit integer*2 (a-z)
  692.       shift=val
  693.       if (dist.eq.0) go to 20
  694.       idist=iabs(dist)
  695.       do 1  i = 1,idist
  696.       if (dist.lt.0) shift=shift/2
  697. 1     if (dist.gt.0) shift=shift*2
  698. 20    return
  699.       end
  700.       subroutine bug(num)
  701.       implicit integer*2 (a-z)
  702.  
  703. c  the following conditions are currently considered fatal bugs.  numbers < 20
  704. c  are detected while reading the database; the others occur at "run time".
  705. c  0      message line > 72 characters
  706. c  1      null line in message
  707. c  2      too many words of messages
  708. c  3      too many travel options
  709. c  4      too many vocabulary words
  710. c  5      required vocabulary word not found
  711. c  6      too many rtext messages
  712. c  7      too many hints
  713. c  8      location has cond bit being set twice
  714. c  9      invalid section number in database
  715. c  20     special travel (500>l>300) exceeds goto list
  716. c  21     ran off end of vocabulary table
  717. c  22     vocabulary type (n/1000) not between 0 and 3
  718. c  23     intransitive action verb exceeds goto list
  719. c  24     transitive action verb exceeds goto list
  720. c  25     conditional travel entry with no alternative
  721. c  26     location has no travel entries
  722. c  27     hint number exceeds goto list
  723. c  28     invalid month returned by date function
  724.  
  725.       write (*,1) num
  726.  1    format (' Fatal error, see source code for interpretation.'/
  727.      . ' Probable cause:  erroneous info in database.'/
  728.      2 ' Error code =',i2/)
  729.       pause 'To Exit From Adventure'
  730.       end
  731.  
  732.       subroutine getin (word1,word1x,word2,word2x)
  733. c  get a command from the adventurer.  snarf out the first word, pad it
  734. c  with blanks, and return in word1--word1x used for overflow charcters
  735. c  5-8 in case we need to print the whole word back out in an error.
  736. c  any number of blanks may follow the word.  if a second word appears
  737. c  it is returned in word2/word2x, else word2 is set to zero.  all are
  738. c  converted to lower case for comparison ease (ibm pc version).
  739.       implicit integer*2 (a-z)
  740.       common /blkcom/ blklin
  741.       character*1 s(20), t(20)
  742.       character*4 word1, word1x, word2, word2x, w1(5), w2(5), a(5)
  743.       character*20 w81, w82, aa, bb
  744.       integer*4 iw1, iw1x, iw2, iw2x
  745.       equivalence (w1(1),iw1),(w1(2),iw1x),(a,aa)
  746.       equivalence (w2(1),iw2),(w2(2),iw2x),(w81,w1),(w82,w2)
  747.       if (blklin.eq.1) write (*,1)
  748. 1     format (1x)
  749. c  give a prompt to make him think we want input
  750.       write (*,9)
  751. 9     format ('   -> ',\)
  752. c
  753. c  read twenty characters into a.  unpack them into s.
  754.       read (*,3) a
  755. 3     format (5a4)
  756.       bb = aa
  757.       call unpack (bb, s)
  758. c  translate all to lower case
  759.       do 1001 i=1,20
  760.       if (ichar(s(i)).lt.65.or.ichar(s(i)).gt.90) go to 1001
  761.       s(i)=char(ichar(s(i))+32)
  762. 1001  continue
  763. c  go through the characters and transfer the first word into t, up
  764. c  to eight characters
  765.       do 10 i=1,20
  766. 10    t(i)=' '
  767.       do 11 i=1,8
  768.       if (s(i).eq.' ') go to 20
  769. 11    t(i)=s(i)
  770. c  now repack the characters into w81, equivalent to word1,word1x
  771. 20    call pack (w81,t)
  772.       word1=w1(1)
  773.       word1x=w1(2)
  774. c  now find a second word if one exists--clear return words first
  775.       iw2=0
  776.       iw2x=0
  777.       do 30 i=1,20
  778. 30    t(i)=' '
  779.       do 31 i=1,20
  780.       if (s(i).ne.' ') go to 31
  781.       go to 32
  782. 31    continue
  783. c  all characters--fooey
  784.       go to 40
  785. c  hit first blank after first word--now get first non-blank
  786. 32    do 33 j=i,20
  787.       if (s(j).eq.' ') go to 33
  788.       go to 34
  789. 33    continue
  790. c  blanked out again
  791.       go to 40
  792. c  hit beginning of second word--finish it
  793. 34    do 35 i=j,20
  794.       if (s(i).eq.' ') go to 36
  795. 35    t(i-j+1)=s(i)
  796. c  now repack word2/2x
  797. 36    call pack (w82,t)
  798. 40    word2=w2(1)
  799.       word2x=w2(2)
  800.       return
  801.       end
  802. c
  803.       subroutine unpack (b, s)
  804.       implicit integer*2 (a-z)
  805. c   unpack general subroutine
  806. c  b  20 character string
  807. c  s  20 character*1 singles
  808.       character*20 a,b
  809.       character*4 aa(5)
  810.       integer*4 ia(5)
  811.       equivalence (ia,a,aa)
  812.       character*1 s(20)
  813.       a = b
  814.       do 1 k = 1,5
  815.       do 1 j = 1,4
  816.       s(4*(k-1)+j)=aa(k)
  817. 1     if(j.ne.4)ia(k)=ia(k)/256
  818.       return
  819.       end
  820. c
  821.       subroutine pack (b, t)
  822.       implicit integer*2 (a-z)
  823. c   general pack subroutine--20 characters
  824. c   b  return packed word--20
  825. c   t  array to pack of char*1's
  826.       character*20 a,b
  827.       integer*4 ia(5)
  828.       equivalence (ia,a)
  829.       character*1 s(20),t(20)
  830.       do 95 i = 1,20
  831. 95      s(i)=t(i)
  832.       do 1 k = 1,5
  833.       ia(6-k)=0
  834.       do 1 j = 1, 4
  835.       l=4*(5-k)+5-j
  836.       ia(6-k) = ia(6-k) + ichar (s(l))
  837. 1     if (j.ne.4) ia(6-k) = ia(6-k) * 256
  838.       b=a
  839.       return
  840.       end
  841. c
  842.       integer*2 function toting(obj)
  843.       implicit integer*2 (a-z)
  844.       common /placom/ atloc,link,place,fixed,holdng
  845.       dimension atloc(150),link(200),place( 100),fixed(100)
  846.       toting=0
  847.       if (place(obj).eq.-1) toting=1
  848.       return
  849.       end
  850. c
  851.       integer*2 function here(obj)
  852.       implicit integer*2 (a-z)
  853.       common /placom/ atloc,link,place,fixed,holdng
  854.       common /loccom/ loc
  855.       dimension atloc(150),link(200),place( 100),fixed(100)
  856.       here=0
  857.       if (place(obj).eq.loc.or.toting(obj).eq.1) here=1
  858.       return
  859.       end
  860. c
  861.       integer*2 function at(obj)
  862.       implicit integer*2 (a-z)
  863.       common /placom/ atloc,link,place,fixed,holdng
  864.       common /loccom/ loc
  865.       dimension atloc(150),link(200),place( 100),fixed(100)
  866.       at=0
  867.       if (place(obj).eq.loc.or.fixed(obj).eq.loc) at=1
  868.       return
  869.       end
  870. c
  871.       integer*2 function forced(loc)
  872.       implicit integer*2 (a-z)
  873.       common /concom/ cond
  874.       dimension cond (150)
  875.       forced=0
  876.       if (cond(loc).eq.2) forced=1
  877.       return
  878.       end
  879. c
  880.       integer*2 function dark(dummy)
  881.       implicit integer*2 (a-z)
  882.       common /concom/ cond
  883.       common /loccom/ loc
  884.       common /procom/ prop, lamp
  885.       dimension cond(150),prop(100)
  886.       external here
  887.       dark=0
  888.       if (mod(cond(loc),2).eq.0 .and. (prop(lamp).eq.0 .or.
  889.      .  here(lamp).eq.0)) dark=1
  890.       return
  891.       end
  892. 
  893.  
  894.